home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr51
/
lib201.zip
/
SCA.PRG
< prev
next >
Wrap
Text File
|
1993-02-23
|
16KB
|
405 lines
*-------------------------------------------------------------------------------
*-- Program...: SCA.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- Notes.....: This file contains the SCA Date handling routines, as well as a
*-- copy of the roman numeral to arabic and vice-versa functions,
*-- that are contained in CONVERT.PRG. This is due to the fact
*-- that only two library files may be open at one time. See
*-- the file README.TXT for more details on the use of this library
*-- file.
*-------------------------------------------------------------------------------
PROCEDURE SCA_Real
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
*-- Date........: 07/29/1991
*-- Notes.......: This procedure was designed to handle data entered into
*-- the Order of Precedence of the Principality of the Mists.
*-- The problem is, my usual sources of data give only SCA
*-- dates, and in order to sort properly, I need real dates.
*-- This procedure will handle it, and goes hand-in-hand with
*-- the function Real_SCA, to translate real dates to SCA
*-- dates ... This procedure assumes that you have set the
*-- F1 Key (see Example below). If you use a different F key,
*-- you will want to modify the ON KEY LABEL commands ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/23/1991 - original procedure.
*-- 07/29/1991 -- modified it to stuff a character directly into
*-- a date field (was having to do a CTOD in the program),
*-- and added use of ESC to escape out, instead of killing
*-- the procedure and the program calling it ...
*-- Calls.......: CENTER Procedure in PROC.PRG
*-- SHADOW Procedure in PROC.PRG
*-- ARABIC() Function in PROC.PRG
*-- ALLTRIM() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do SCA_Real
*-- Example.....: on key label f1 do sca_real
*-- store {} to t_date && initialize as a date
*-- && or you could STORE datefield to t_date
*-- && if you have a date field ...
*-- clear
*-- @5,10 say "Enter a date:" get t_date;
*-- message "Press <F1> to convert from SCA date to real date"
*-- read
*-- on key label f1 && clear out that command ...
*-- Returns.....: real date, forced into field ...
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,nMonth
private nDay,cDate
cEscape = set("ESCAPE")
set escape off && so we can handle the Escape Key
cExact = set("EXACT")
set exact on && VERY important ...
on key label F1 ?? chr(7) && make it beep, rather than call this procedure
&& again, which causes wierdnesses ...
*-- first let's popup a window to ask for the information ...
save screen to sDate
activate screen
define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
do shadow with 8,20,15,60
activate window wDate
*-- set the memvars ...
cYear = space(8)
cMonth = space(3)
cDay = space(2)
do center with 0,40,"","Enter SCA Date below:"
do while .t.
@2,14 say "Month: " get cMonth ;
picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
message "Enter first letter of month, <Space> to scroll through, "+;
"<Enter> to choose" color rg+/gb,n/g
@3,14 say " Day: " get cDay picture "99";
message "Enter 2 digits for day of the month, if blank will assume 15";
color rg+/gb,n/g
@4,14 say " Year: " get cYear picture "!!!!!!!!" ;
message "Enter year in AS roman numeral format";
valid required len(trim(cYear)) > 0;
error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
read
if lastkey() = 27 && if user wants out by pressing <Esc>
deactivate window wDate
release window wDate
restore screen from sDate
release screen sDate
set escape &cEscape
set exact &cExact
on key label F1 do SCA_Real && reset it ...
return
endif
if lastkey() < 0 && function key F1 through Shift F9 was pressed
?? chr(7) && beep at user
loop && don't let 'em get away with that -- try again
endif
*-- check for valid roman numerals
cYear = trim(cYear) && trim it
nYearLen = len(cYear) && get length
nCount = 0
do while nCount < nYearLen && loop through length of year
nCount = nCount + 1 && increment
if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
lError = .t. && set error flag
exit && exit internal loop
else
lError = .f. && make sure this is false
endif
enddo && end of internal loop
if lError && if error,
loop && go back ...
endif
@5,0 clear && clear out any error message ...
do center with 5,40,"rg+/r","Converting Date ..."
*-- First (and most important) is conversion of the year
nYear = Arabic(cYear)
*-- AS Years start at May ... if the month for a specific year is
*-- Jan through April it's part of the next "real" year ...
if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
cMonth = "APR"
nYear = nYear + 1
endif
nYear = nYear + 65 && SCA dates start at 66 ...
if nYear > 99 && this thing doesn't handle turn of the century
@5,0 clear
do center with 5,40,"rg+/r","No dates past XXXIV, please"
loop
endif
*-- set numeric value of month ...
do case
case cMonth = "JAN"
nMonth = 1
case cMonth = "FEB"
nMonth = 2
case cMonth = "MAR"
nMonth = 3
case cMonth = "APR"
nMonth = 4
case cMonth = "MAY"
nMonth = 5
case cMonth = "JUN"
nMonth = 6
case cMonth = "JUL"
nMonth = 7
case cMonth = "AUG"
nMonth = 8
case cMonth = "SEP"
nMonth = 9
case cMonth = "OCT"
nMonth = 10
case cMonth = "NOV"
nMonth = 11
case cMonth = "DEC"
nMonth = 12
endcase
*-- if the day field is empty, assume the middle of the month, so we
*-- have SOMETHING to go by ...
if len(alltrim(cDay)) = 0
nDay = 15
else
nDay = val(cDay)
endif
*-- Check for valid day of the month ...
if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
loop
endif
exit && out of loop -- if here, we're done
enddo && end of loop
*-- Convert it
cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
transform(nYear,"@L 99")
*-- force this 'character' date into the date field on the screen ...
keyboard cDate clear && put it into the field, and clear out
&& keyboard buffer first ...
*-- deal with cleanup ...
deac wind wDate
release wind wDate
restore screen from sDate
release screen sDate
set escape &cEscape
set exact &cExact
on key label F1 do SCA_Real && reset for user
RETURN
*-- EoP: SCA_Real
FUNCTION SCA2Real
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/22/1992
*-- Notes.......: Jay figured out a short version of SCA_Real above, which
*-- does not use screen input/screen display. This can be used
*-- directly as a function.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 04/22/1992 -- Original Release
*-- Calls.......: ALLTRIM() Function in PROC.PRG
*-- ARABIC() Function in CONVERT.PRG (and below)
*-- Called by...: Any
*-- Usage.......: SCA2Real(<cDay>,<cMonth>,<cYear>)
*-- Example.....: ?SCA2Real("12","JAN","XXVI")
*-- Returns.....: dBASE Date (from example above: 01/12/92)
*-- Parameters..: cDay = Character day of month
*-- cMonth = Character day of month
*-- cYear = Roman Numeric version of year (SCA dates)
*-------------------------------------------------------------------------------
parameters cDay, cMonth, cYear
private nMonth, nDay, nYear
nMonth = at(upper(left(cMonth,3))," JAN FEB MAR APR MAY JUN";
+" JUL AUG SEP OCT NOV DEC") /4
nDay = iif(""=alltrim(cDay),15,val(cDay))
nYear = arabic(cYear)+1965+iif(nMonth < 5,1,0)
RETURN ctod(right(str(nMonth+100),2)+"/";
+right(str(nDay+100),2)+"/"+str(nYear))
*-- EoF: SCA2Real()
FUNCTION Real_SCA
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
*-- Date........: 07/23/1991
*-- Notes.......: This procedure was designed to handle data entered into
*-- the Order of Precedence of the Principality of the Mists.
*-- For the purpose of printing the Order of Precedence, it
*-- is necessary to convert real dates to SCA dates. I needed
*-- to store the data as real dates, but I want it to print with
*-- SCA dates ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/23/1991 -- Original Release
*-- Calls.......: ROMAN() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Real_SCA(<dDate>)
*-- Example.....: @nLine,25 say Real_SCA(CA) && print SCA date for Corolla
*-- && Aulica
*-- Returns.....: SCA Date based on dDate
*-- Parameters..: dDate = date to be converted
*-------------------------------------------------------------------------------
PARAMETERS dDate && a real date, to be converted to an SCA date ...
private nYear,nMonth,cMonth,cDay
nYear = year(dDate) - 1900 && remove the century
nMonth = month(dDate)
cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
cDay = ltrim(str(day(dDate))) && convert day to character
*-- First (and most important) is conversion of the year
*-- this is set to the turn of the century ... (AS XXXV)
*-- AS Years start at May ... if the month for a specific year is
*-- Jan through April it's part of the previous SCA year
*-- (April '67 = April AS I, not II)
if nMonth < 5
nYear = nYear - 1
endif
nYear = nYear - 65 && SCA dates start at 66
cYear = Roman(nYear)
RETURN cMonth+" "+cDay+", "+"AS "+cYear
*-- EoF: Real_SCA()
*-------------------------------------------------------------------------------
*-- These two functions were included in this library file, so that you (or I)
*-- do not have to figure a way to combine the functions below from CONVERT.PRG
*-- and this file into one library file.
*-------------------------------------------------------------------------------
FUNCTION Roman
*-------------------------------------------------------------------------------
*-- Programmer..: Nick Carlin
*-- Date........: 04/26/1992
*-- Notes.......: A function designed to return a Roman Numeral based on
*-- an Arabic Numeral input ...
*-- Written for.: dBASE III+
*-- Rev. History: 04/13/1988 - original function.
*-- 07/25/1991 - Ken Mayer - 1) modified for dBASE IV, 1.1,
*-- 2) updated to a function, and 3) the procedure
*-- GetRoman was done away with (combined into the
*-- function).
*-- 04/26/1992 - Jay Parsons - shortened (seriously ...)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Roman(<nArabic>)
*-- Example.....: ? Roman(32)
*-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
*-- passed to it. In example: XXXII
*-- Parameters..: nArabic = Arabic number to be converted to Roman
*-------------------------------------------------------------------------------
parameters nArabic
private cLetrs,nCount,nValue,cRoman,cGroup,nMod
cLetrs ="MWYCDMXLCIVX" && Roman digits
cRoman = "" && this is the returned value
nCount = 0 && init counter
do while nCount < 4 && loop four times, once for thousands, once
&& for each of hundreds, tens and singles
nValue = mod( int( nArabic / 10 ^ ( 3 - nCount ) ), 10 )
cGroup = substr( cLetrs, nCount * 3 + 1, 3 )
nMod = mod( nValue, 5 )
if nMod = 4
if nValue = 9 && 9
cRoman = cRoman + left( cGroup, 1 ) + right( cGroup, 1 )
else && 4
cRoman = cRoman + left( cGroup, 2 )
endif
else
if nValue > 4 && 5 - 8
cRoman = cRoman + substr( cGroup, 2, 1 )
endif
if nMod > 0 && 1 - 3 and 6 - 8
cRoman = cRoman + replicate( left( cGroup, 1 ), nMod )
endif
endif
nCount = nCount + 1
enddo && while nCounter < 4
RETURN cRoman
*-- EoF: Roman()
FUNCTION Arabic
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 04/26/1992
*-- Notes.......: This function converts a Roman Numeral to an arabic one.
*-- It parses the roman numeral into an array, and checks each
*-- character ... if the previous character causes the value to
*-- subtract (for example, IX = 9, not 10) we subtract that value,
*-- and then set the previous value to 0, otherwise we would get
*-- some odd values in return.
*-- So far, it works fine.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/15/1991 - original function.
*-- 04/26/1992 - Jay Parsons - shortened.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Arabic(<cRoman>)
*-- Example.....: ?Arabic("XXIV")
*-- Returns.....: Arabic number (from example, 24)
*-- Parameters..: cRoman = character string containing roman numeral to be
*-- converted.
*-------------------------------------------------------------------------------
parameters cRoman
private cRom,cLetrs,nLast,nAt,nVal,cChar,nArabic
cRom = ltrim(trim(upper(cRoman))) && convert to all caps in case ...
cLetrs = "IVXLCDMWY"
nArabic = 0
nLast = 0
do while len( cRom ) > 0
cChar = right( cRom, 1 )
nAt = at( cChar, cLetrs )
nVal= 10 ^ int( nAt/2 ) / iif(nAt/2 = int(nAt/2),2,1)
do case
case nAt = 0
nArabic = 0
exit
case nAt >= nLast
nArabic = nArabic + nVal
nLast = nAt
otherwise
if nAt/2 = int( nAt / 2 )
nArabic = 0
exit
else
nArabic = nArabic - nVal
endif
endcase
cRom = left( cRom, len( cRom ) - 1 )
enddo
RETURN nArabic
*-- EoF: Arabic()
*-------------------------------------------------------------------------------
*-- EoP: SCA.PRG
*-------------------------------------------------------------------------------